;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; -hook
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define* (make-hook)
  (let ((procedures '()))
    (lambda* (#:optional procedure)
      (if procedure
          (set! procedures (append procedures (list procedure)))
          (map (lambda (procedure) (procedure)) procedures))
      #t)))
(define (add-hook hook procedure) (hook procedure))
(define (run-hooks hook) (hook))

(define-syntax define-hook
  (syntax-rules ()
    ((define-hook hook)
     (begin
       (define hook (make-hook))
       #t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; vice-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define vice-amode)
(define (vice-make-amode amode amode-hook)
  (lambda* (#:optional kname)
    (set! vice-key-alist '())
    (set! vice-amode amode)
    (run-hooks amode-hook)
    #t))
(define vice-key-alist)
(define (vice-set-key key binding)
      (set! vice-key-alist (assoc-set! vice-key-alist key binding))
      #t)
(define vice-screen)
(define vice-start-input-loop)
(define vice-stop-input-loop)
(letrec* ((vice-discontinue-input-loop #f)
          (vice-input-loop
            (lambda* (#:optional prev-outcome)
              (if vice-discontinue-input-loop
                  #t
                  (letrec* ((key (getch vice-screen))
                            (kname (and key (keyname key)))
                            (act (and kname
                                      (assoc-ref vice-key-alist kname)))
                            (eval-acts
                              (lambda (acts)
                                (if (= (length acts) 1)
                                  ((car acts) kname)
                                  (if (not (equal? #t ((car acts) kname)))
                                      (throw 'intermediate-action-failed)
                                      (eval-acts (cdr acts)))))))
                    (display kname) (newline) (force-output)
                    (vice-input-loop
                      (if (procedure? prev-outcome)
                          (prev-outcome kname)
                          (if act
                              (eval-acts (if (list? act) act (list act)))
                              #f))))))))
  (set! vice-start-input-loop
    (lambda ()
      (set! vice-discontinue-input-loop #f)
      (vice-input-loop)))
  (set! vice-stop-input-loop
    (lambda* (#:optional kname)
      (set! vice-discontinue-input-loop #t)
      #t)))

(define (vice)
  (set! vice-screen (stdscr))
  (keypad! vice-screen #t)
  (noecho!)
  (normal-amode)
  (vice-start-input-loop))

(define-syntax define-amode
  (syntax-rules ()
    ((define-amode amode amode-hook amode-set-key)
     (begin (define-hook amode-hook)
            (define amode (vice-make-amode 'amode amode-hook))
            (define (amode-set-key key binding)
              (add-hook amode-hook (lambda () (vice-set-key key binding))))))))

(define-amode normal-amode normal-amode-hook normal-set-key)
(define-amode insert-amode insert-amode-hook insert-set-key)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; configuration
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; debugging
(normal-set-key "^Q" vice-stop-input-loop)

;; ;; changing amodes
(normal-set-key "i" insert-amode)
;; (normal-set-key "a" '(insert-amode next-character))
;; (normal-set-key "o" '(insert-amode next-line))
;; (normal-set-key "O" '(insert-amode previous-line))
(insert-set-key "^C" normal-amode)
 
;; ;; normal amode: motions
;; (normal-set-key "h" previous-character)
;; (normal-set-key "l" next-character)
;; (normal-set-key "j" previous-line)
;; (normal-set-key "k" next-line)
;; (normal-set-key "KEY_LEFT" previous-character)
;; (normal-set-key "KEY_RIGHT" next-character)
;; (normal-set-key "KEY_UP" previous-line)
;; (normal-set-key "KEY_DOWN" next-line)
;; (normal-set-key "gg" goto-first-line)
;; (normal-set-key "G" goto-last-line)

;; ;; normal amode: undo and redo
;; (normal-set-key "u" undo)
;; (normal-set-key "U" undo-line-changes)
;; (normal-set-key "^R" redo)
;; (normal-set-key "ZZ" '(save-buffer kill-buffer))

;; ;; normal amode: search
;; (normal-set-key "f" search-forward-character)
;; (normal-set-key "F" search-backward-character)
;; (normal-set-key "/" search-forward-string)
;; (normal-set-key "?" search-backward-string)
;; (normal-set-key "n" search-repeat)
;; (normal-set-key "N" search-reverse-repeat)

;; ;; normal amode: delete action
;; (normal-set-key "d" delete-region)
;; (normal-set-key "dd" '(delete-region current-line))

;; ;; normal amode: change action
;; (normal-set-key "c" '(delete-region '_ insert-amode))
;; (normal-set-key "cc" '(delete-region current-line insert-amode))

;; ;; insert amode: motions
;; (insert-set-key "KEY_LEFT" previous-character)
;; (insert-set-key "KEY_RIGHT" next-character)
;; (insert-set-key "KEY_UP" previous-line)
;; (insert-set-key "KEY_DOWN" next-line)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; startup
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(vice)
